home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / initAlphaTcl.tcl < prev    next >
Encoding:
Text File  |  2001-01-15  |  10.8 KB  |  338 lines
  1. # If we have already sourced this file, then this variable will exist
  2. if {[info exists global::features]} { return }
  3.  
  4. # First basic initialisation: (works with Alpha 7.2.1 or 8.0 development)
  5. if {[info tclversion] < 8.0} {
  6.     ;proc namespace {cmd ns script} {if {$script != ""} {uplevel $script}}
  7.     ;proc variable {n} { global mode ; uplevel 1 [list upvar \#0 $mode::$n $n] }
  8.     ;proc renameMenuItem {args} {}
  9. } else {
  10.     namespace eval alpha {
  11.     namespace eval index {}
  12.     namespace eval cache {}
  13.     }
  14.     namespace eval win {}
  15.     if {[info commands scancontext] == ""} {
  16.     namespace eval scancontext {
  17.         namespace export *
  18.     }
  19.     proc scancontext::scancontext {cmd args} {
  20.         switch -- $cmd {
  21.         "create" {
  22.             uplevel 1 {
  23.             set __scan 0
  24.             while {1} {
  25.                 incr __scan
  26.                 variable scancontext$__scan
  27.                 if {![array exists scancontext$__scan]} {
  28.                 break
  29.                 }
  30.             }
  31.             set scancontext[set __scan]() 1
  32.             return scancontext$__scan
  33.             }
  34.         }
  35.         "delete" {
  36.             variable [lindex $args 0]
  37.             unset [lindex $args 0]
  38.         }
  39.         }
  40.     }
  41.     
  42.     proc scancontext::scanmatch {scanid regexp script args} {
  43.         if {[string match "-*" $scanid]} {
  44.         set flags $scanid
  45.         set scanid $regexp
  46.         set regexp [list $flags $script]
  47.         set script [lindex $args 0]
  48.         } else {
  49.         set regexp [list -- $regexp]
  50.         }
  51.         variable $scanid
  52.         set ${scanid}($regexp) $script
  53.         return $scanid
  54.     }
  55.     
  56.     proc scancontext::scanfile {scanid fid} {
  57.         variable $scanid
  58.         upvar matchInfo m
  59.         set m(linenum) 0
  60.         set m(offset) 0
  61.         set m(handle) $fid
  62.         set names [array names $scanid]
  63.         while {[set count [gets $fid m(line)]] >= 0} {
  64.         incr m(linenum)
  65.         incr m(offset) [expr {$count +1}]
  66.         foreach reg $names {
  67.             if {$reg == ""} {continue}
  68.             if {[regexp [lindex $reg 0] [lindex $reg 1] $m(line) \
  69.               "" m(submatch0) m(submatch1) m(submatch2)]} {
  70.             incr m(offset) [expr {-[string length $m(submatch0)]}]
  71.             uplevel 1 [set ${scanid}($reg)]
  72.             incr m(offset) [string length $m(submatch0)]
  73.             }
  74.         }
  75.         }
  76.     }
  77.     namespace import scancontext::*
  78.     }
  79.     rename lsort __lsort
  80.     proc lsort {args} {
  81.     if {[lindex $args 0] == "-ignore"} {
  82.         eval __lsort -dictionary [lrange $args 1 end]
  83.     } else {
  84.         eval __lsort $args
  85.     }
  86.     }
  87.     # Tcl 8.0 doesn't handle \t \r \n , but Tcl 8.1 will
  88.     if {[info tclversion] == 8.0} {
  89.     rename regexp __regexp
  90.     proc regexp {args} {
  91.         set i 0
  92.         while {[string match -* [set a [lindex $args $i]]]} {
  93.         incr i
  94.         if {$a == "--"} {
  95.             set a [lindex $args $i]
  96.             break
  97.         }
  98.         }
  99.         __regsub -all "\\\\t" $a "\t" a
  100.         __regsub -all "\\\\r" $a "\r" a
  101.         __regsub -all "\\\\n" $a "\n" a
  102.         __regsub -all "\\\\w" $a "\[a-zA-Z0-9_\]" a
  103.         __regsub -all "\\\\s" $a "\[ \t\r\n\]" a
  104.         uplevel __regexp [lreplace $args $i $i $a]
  105.     }
  106.     rename regsub __regsub
  107.     proc regsub {args} {
  108.         set i 0
  109.         while {[string match -* [set a [lindex $args $i]]]} {
  110.         incr i
  111.         if {$a == "--"} {
  112.             set a [lindex $args $i]
  113.             break
  114.         }
  115.         }
  116.         __regsub -all "\\\\" $a "¢¢" a
  117.         __regsub -all "\\\\t" $a "\t" a
  118.         __regsub -all "\\\\r" $a "\r" a
  119.         __regsub -all "\\\\n" $a "\n" a
  120.         __regsub -all "\\\\w" $a "\[a-zA-Z_\]" a
  121.         __regsub -all "\\\\s" $a "\[ \t\r\n\]" a
  122.         __regsub -all "¢¢" $a "\\\\" a
  123.         uplevel __regsub [lreplace $args $i $i $a]
  124.     }
  125.     }
  126.     
  127.     if {$tcl_platform(platform) == "macintosh"
  128.     &&    [llength [info commands alert]] > 0} {
  129.         
  130.         rename alertnote __alertnote
  131.         proc alertnote {args} {
  132.             alert -t stop -c "" -o "" [lindex $args 0] [join [lrange $args 1 end] " "]
  133.             return
  134.         }
  135.  
  136.  
  137.         rename askyesno __askyesno
  138.         proc askyesno {args} {
  139.             if {[lindex $args 0] == "-c"} {
  140.                 set button [alert -t caution -k "Yes" -c "No" -o "Cancel" -C other [lindex $args 1]]
  141.             } else {
  142.                 set button [alert -t caution -k "Yes" -c "No" -o "" -C none [lindex $args 0]]
  143.             }
  144.                
  145.             return [string tolower $button]
  146.         }
  147.  
  148.  
  149.         rename buttonAlert __buttonAlert
  150.         proc buttonAlert {prompt args} {
  151.             set buttonCount [llength $args]
  152.  
  153.             if {$buttonCount > 3} {
  154.                 eval __buttonAlert [list $prompt] $args
  155.             } else {
  156.                 set cmd [list alert -t caution -c "" -o ""]
  157.                 if {$buttonCount > 0} {
  158.                     set defaultText [lindex $args 0]
  159.                     lappend cmd -k $defaultText
  160.                     if {[string tolower $defaultText] == "cancel"} {
  161.                         lappend cmd -C ok -K cancel
  162.                     } 
  163.                     if {$buttonCount > 1} {
  164.                         set cancelText [lindex $args 1]
  165.                         lappend cmd -c $cancelText
  166.                         if {[string tolower $cancelText] == "cancel"} {
  167.                             lappend cmd -C cancel
  168.                         } 
  169.                         if {$buttonCount > 2} {
  170.                             set otherText [lindex $args 2]
  171.                             lappend cmd -o $otherText
  172.                             if {[string tolower $otherText] == "cancel"} {
  173.                                 lappend cmd -C other
  174.                             } 
  175.                         }
  176.                     }
  177.                 }
  178.                 
  179.                 lappend cmd $prompt
  180.                     
  181.                 eval $cmd
  182.             }
  183.         }
  184.     }
  185.     
  186. }    
  187.  
  188. # Get the Tcl environment setup correctly
  189. if {[catch [list source [file join $HOME Tcl SystemCode initTcl.tcl]] err]} {
  190.     alertnote "There was a bad problem while sourcing initTcl.tcl"
  191.     error $err
  192. }
  193.  
  194. # Read Alpha's version information
  195. if {[catch [list source [file join $HOME Tcl SystemCode alphaVersionInfo.tcl]] err]} {
  196.     alertnote "There was a bad problem while sourcing alphaVersionInfo.tcl"
  197.     error $err
  198. }
  199. # PREFS points to a folder 'Alpha', we add the major version number
  200. append PREFS "-v[lindex [split ${alpha::version} .] 0]"
  201.  
  202. if {[info commands alphaOpen] == ""} {
  203.     # Can be overridden to cope with cross-platform encoding issues
  204.     proc alphaOpen {args} { uplevel 1 open $args }
  205. }
  206. if {[info commands alpha::showStartupVersions] != ""} {
  207.     alpha::showStartupVersions
  208. }
  209. if {![info exists alpha::modifier_keys]} {
  210.     set alpha::modifier_keys [list "Command" "cmd" "Option" "opt"]
  211. }
  212.  
  213. set alpha::noMenusYet 1
  214. set alpha::changingMode 0
  215. if {$tcl_platform(platform) == "macintosh" && [info tclversion] > 8.0} {
  216.     if {"\u0192" != "ƒ"} {
  217.     if {![file exists [file join [info library] encoding]]} {
  218.         alertnote "Your 'encoding' directory inside Tcl's library\
  219.           '[info library]' doesn't seem to exist.  This will\
  220.           probably cause serious problems."
  221.     } else {
  222.         alertnote "Unknown encoding problem.  Make sure you\
  223.           have installed Tcl properly.  This will\
  224.           probably cause serious problems."
  225.     }
  226.     }
  227. }
  228. # source v. important code
  229. if {[catch [list source [file join $HOME Tcl SystemCode library.tcl]] err]} {
  230.     alertnote "There was a bad problem while sourcing library.tcl"
  231.     error $err
  232. }
  233. if {[catch [list source [file join $HOME Tcl SystemCode coreFixes.tcl]] err]} {
  234.     alertnote "There was a bad problem while sourcing coreFixes.tcl"
  235.     error $err
  236. }
  237. # check if the user over-rides things
  238. if {[file exists [file join ${HOME} AlphaPrefs]] \
  239.   && [file isdirectory [file join ${HOME} AlphaPrefs]]} {
  240.     foreach PREFS [glob -types d -dir $HOME *] {
  241.     if {[string tolower [file join ${HOME} alphaprefs]] ==
  242.     [string tolower $PREFS]} {
  243.         break
  244.     }
  245.     }
  246. } else {        
  247.     if {![file exists $PREFS]} { 
  248.     if {[catch {file mkdir $PREFS}]} {
  249.         alertnote "I cannot locate or create your preferences\
  250.           directory '$PREFS'.  From now on I'll try to use \
  251.           '[file join ${HOME} AlphaPrefs]' instead."
  252.         set PREFS [file join ${HOME} AlphaPrefs]
  253.         if {![file exists $PREFS]} { 
  254.         if {[catch {file mkdir $PREFS}]} {
  255.             alertnote "Sorry, I couldn't make '$PREFS'.  Alpha\
  256.               requires a preferences directory to run.  Please fix\
  257.               this problem and then try to rerun Alpha.  Goodbye."
  258.             quit
  259.         }
  260.         }
  261.     } else {
  262.         # We have to be careful here; Alpha has hardly started up so we can't
  263.         # yet access most of AlphaTcl.
  264.         set major_version [lindex [split ${alpha::version} .] 0]
  265.         if {[file tail $PREFS] == "Alpha-v$major_version"} {
  266.         # We just created a new folder for a major version of Alpha
  267.         set prev_prefs [file join [file dirname $PREFS] "Alpha-v[expr {$major_version -1}]"]
  268.         if {[file exists $prev_prefs]} {
  269.             # And it was an upgrade, since the old prefs folder exists.
  270.             # If the old version is compatible, copy it over
  271.             if {[info exists alpha::majorUpgradePrefsCompatible]} {
  272.             if {[askyesno "You just upgraded to a new major version\
  273.               ${alpha::version} from [expr {$major_version -1}].x.\
  274.               Would you like me to copy over your preferences (they should\
  275.               be compatible)?"] == "yes"} {
  276.                 # Copy contents of prev prefs to new $PREFS
  277.                 if {[catch {eval file copy [glob -dir $prev_prefs *] [list $PREFS]}]} {
  278.                 alertnote "There was an error copying your preferences;\
  279.                   this may cause problems"
  280.                 }
  281.             }
  282.             } else {
  283.             alertnote "You just upgraded to a new major version\
  284.               ${alpha::version} from [expr {$major_version -1}].x.\
  285.               The preferences are largely incompatible between these\
  286.               two versions, so you'll have to re-enter them."
  287.             }
  288.             # Then ask if we should delete the old one
  289.             if {[askyesno "Should I delete your old preferences?"] == "yes"} {
  290.             if {[catch {file delete -force $prev_prefs}]} {
  291.                 alertnote "There was an error deleting your old preferences;\
  292.                   you might want to delete '$prev_prefs' manually."
  293.             }
  294.             }
  295.         }
  296.         unset prev_prefs
  297.         }
  298.         unset major_version
  299.     }
  300.     }
  301. }
  302.  
  303. if {[info tclversion] < 8.0} {
  304.     set auto_path {}
  305. }
  306.  
  307. if {[catch [list alpha::makeAutoPath 0 $skipPrefs] err]} {
  308.     alertnote "There was a bad problem while making the autopath"
  309.     error $err
  310. }
  311. # Check whether we are likely to have some bad problems
  312. # usually caused by corrupt/badly out of date Tcl
  313. # indices, or a bad/partial installation.
  314. set err [expr {![auto_load cache::readContents]}]
  315.  
  316. # IMPORTANT: it is vital we get to this point in the startup sequence
  317. # without any errors.  From this point on if we hit any errors, we
  318. # should be able to handle them reasonably gracefully, although
  319. # even then we might force/ask the user to quit.  However errors prior
  320. # to this point probably can't even be dealt with in a useful way,
  321. # basically because we only load the 'unknown' procedure just above.
  322.  
  323. # get known packages
  324. catch {cache::readContents index::feature}
  325. # get list of packages of flag type
  326. catch {cache::readContents index::flags}
  327. # load any early preferences (e.g. list of active packages)
  328. # from special cache
  329. namespace eval global {}
  330. if {!$skipPrefs} {
  331.     catch {cache::readContents configuration}
  332.     catch {unset mode::defaultfeatures}
  333. }
  334. if {![info exists global::features]} {
  335.     set global::features ""
  336.     set firsttime 1
  337. }
  338.